home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 3 / BBS in a box - Trilogy III.iso / Files / Prog / D-G / FORTRAN Goodies / String Utilities / StringWord.f < prev   
Encoding:
Text File  |  1990-10-25  |  2.1 KB  |  98 lines  |  [TEXT/MPS ]
  1. c
  2. c     Returns the N-th word (space delimited)
  3. c
  4. c     Function StringWord
  5. c        Takes a string and an integer*4 word number as input.
  6. c        Returns a PASCAL-type string (word n) as result.
  7. c        note: words are separated by whitespace
  8. c
  9. c    Example provided for owners of Language Systems FORTRAN
  10. c    © 1990 Language Systems Corp.
  11. c
  12. c    Adapted from a routine in Wild Things.
  13. c
  14.      string function StringWord(theString,theWordNumber)
  15.         
  16. C        receive the argument by Descriptor
  17.  
  18.     structure /DescRec/
  19.         pointer /character*1/ DataPtr
  20.         integer*2 DataSize
  21.         integer*2 SymT
  22.     end structure
  23.     record /DescRec/ theString
  24.  
  25.     integer*4         chard,strngd
  26.     parameter         (chard=18,strngd=19)
  27.  
  28.     integer*4        StringLen,theWordNumber
  29.     integer*4        Word,startC,stopC
  30.     pointer            /character*1/ ptr1,ptr2,ptr3
  31.     logical*4        WhiteSpace
  32.  
  33. C put the address of the characters into a local variable
  34.     
  35.     ptr1 = theString.DataPtr
  36.  
  37. C  store the size of the string
  38.  
  39.     StringLen = MIN(255,ichar(ptr1^))
  40.     ptr1 = ptr1 + 1
  41.  
  42. c skip any words we don't want
  43.  
  44.     ptr2 = ptr1
  45.     Word = 1
  46.     do while (Word < theWordNumber)
  47.         do while ((WhiteSpace(ptr2)) .and. ((ptr2-ptr1) < StringLen))
  48.             ptr2 = ptr2 + 1
  49.         end do
  50.         do while ((.not. WhiteSpace(ptr2)) .and. ((ptr2-ptr1) < StringLen))
  51.             ptr2 = ptr2 + 1
  52.         end do
  53.         Word = Word + 1
  54.     end do
  55.  
  56. c skip any white space before desired word
  57.  
  58.     do while ((WhiteSpace(ptr2)) .and. ((ptr2-ptr1) < StringLen))
  59.         ptr2 = ptr2 + 1
  60.     end do
  61.     startC = 1 + (ptr2 - ptr1)
  62.     
  63. c find the end of the word
  64.  
  65.     ptr3 = ptr2
  66.     do while ((.not. WhiteSpace(ptr3)) .and. ((ptr3-ptr1) < StringLen))
  67.         ptr3 = ptr3 + 1
  68.     end do
  69.     stopC = startC + (ptr3 - ptr2) - 1
  70.     if (stopC < startC) stopC = startC
  71.  
  72.     StringWord = ptr1^(startC:stopC)
  73.     
  74.     return
  75.     end
  76. c
  77. c**************************************************c
  78. c
  79. c Function WhiteSpace
  80. c    Takes a pointer to a character as input.
  81. c    Returns a logical*4 TRUE if the character
  82. c      is a tab,return or space.
  83. c
  84.     logical*4 function WhiteSpace(ptr)
  85.     
  86.     pointer /byte/ ptr
  87.     
  88.     select case(ptr^)
  89.         case(9,13,32)    !ASCII values of tab, return, space
  90.             WhiteSpace = .true.
  91.         case default
  92.             WhiteSpace = .false.
  93.     end select
  94.     return
  95.     end
  96. c
  97. c****************************************c
  98.